home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN1.LZH / KEYHIT.FOR < prev    next >
Text File  |  1988-02-08  |  4KB  |  134 lines
  1.       SUBROUTINE KEYHIT ( CHAR, ERROR )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          KEYHIT           **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          KEY HIT
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CALIF  94035
  19. C*          (415) 694-5578
  20. C*  NOTE: THIS ROUTINE IS BASED ON THE DECUS ROUTINE 'READKEY' BY R.F.WREN
  21. C*
  22. C*
  23. C*     PURPOSE :
  24. C*          THIS ROUTINE CHECKS THE KEYBOARD TO SEE IF A KEY HAS BEEN
  25. C*          STRUCK.  IF SO, THE ASCII VALUE OF THE CHARACTER IS RETURNED
  26. C*          IN CHAR; OTHERWISE, 0 IS RETURNED IN CHAR.
  27. C*
  28. C*     INPUT ARGUMENTS :
  29. C*          NONE
  30. C*
  31. C*     OUTPUT ARGUMENTS :
  32. C*          CHAR  - THE ASCII INTEGER CHARACTER THAT WAS ENTERED, OR 0
  33. C*          ERROR - TRUE IF AN ERROR OCCURRED.
  34. C*
  35. C*     INTERNAL WORK AREAS :
  36. C*          NONE
  37. C*
  38. C*     COMMON BLOCKS :
  39. C*          NONE
  40. C*
  41. C*     FILE REFERENCES :
  42. C*          NONE
  43. C*
  44. C*     SUBPROGRAM REFERENCES :
  45. C*          SYS$ASSIGN, SUS$GET_EF, SYS$CLREF, SYS$QIOW
  46. C*
  47. C*     ERROR PROCESSING :
  48. C*          PASSES ALONG THE ERROR CODES FROM THE SYSTEM SERVICES
  49. C*
  50. C*     TRANSPORTABILITY LIMITATIONS :
  51. C*          NOT TRANSPORTABLE
  52. C*
  53. C*     ASSUMPTIONS AND RESTRICTIONS :
  54. C*          THIS ROUTINE WORKS ONLY TO 'TT:'
  55. C*          THE USER SHOULD ALWAYS CHECK THE VALUE OF 'ERROR' IN THE
  56. C*                 CALLING PROGRAM.
  57. C*
  58. C*     LANGUAGE AND COMPILER :
  59. C*          ANSI FORTRAN 77
  60. C*
  61. C*     VERSION AND DATE :
  62. C*          VERSION I.0     28-FEB-85
  63. C*
  64. C*     CHANGE HISTORY :
  65. C*          28-FEB-85    INITIAL VERSION
  66. C*
  67. C***********************************************************************
  68. C*
  69.       IMPLICIT INTEGER (A-Z)
  70.       EXTERNAL SS$_NORMAL, IO$_TTYREADALL, IO$M_TIMED, IO$M_NOECHO
  71.       EXTERNAL SS$_WASCLR, SS$_WASSET
  72.       SAVE INIT, TERM_CHAN, KEYBOARD_EF, READ_FUNC
  73.       LOGICAL ERROR, INIT
  74.       BYTE CHAR
  75.       DATA NO_TIME /0/, INIT/.FALSE./
  76. C
  77. C... ERROR MASKS
  78. C
  79.       INTEGER*2 IOSB(4)
  80.       DATA STATUS /1/, BYTECNT /2/, TERMINATOR /3/, TERMINSIZ /4/
  81. C
  82. C... TERMINATOR TABLE WITH NO TERMINATORS
  83. C
  84.       INTEGER*4 NO_TERMINATORS(2), TERM_MASK(8)
  85.       DATA NO_TERMINATORS /32,0/
  86.       DATA TERM_MASK /'00000000'X,'00000000'X,'00000000'X,'00000000'X,
  87.      $                '00000000'X,'00000000'X,'00000000'X,'00000000'X/
  88.       NO_TERMINATORS(2) = %LOC(TERM_MASK)
  89. C
  90.       ERROR = .FALSE.
  91.       IF (.NOT. INIT) THEN
  92. C
  93. C ASSIGN AN IO CHANNEL FOR TT:
  94. C
  95.          ISTAT = SYS$ASSIGN ('TT', TERM_CHAN,,)
  96.          IF (ISTAT .NE. %LOC(SS$_NORMAL)) THEN
  97.             ERROR = .TRUE.
  98.             RETURN
  99.          ENDIF
  100. C
  101. C ALLOCATE AN EVENT FLAG AND CLEAR IT
  102. C
  103.          ISTAT = LIB$GET_EF(KEYBOARD_EF)
  104.          IF (ISTAT .NE. %LOC(SS$_NORMAL)) THEN
  105.             ERROR = .TRUE.
  106.             RETURN
  107.          ENDIF
  108.          ISTAT = SYS$CLREF (%VAL(KEYBOARD_EF))
  109.          IF (ISTAT .NE. %LOC(SS$_WASCLR)  .AND.
  110.      $       ISTAT .NE. %LOC(SS$_WASSET)) THEN
  111.             ERROR = .TRUE.
  112.             RETURN
  113.          ENDIF
  114.          READ_FUNC = %LOC(IO$_TTYREADALL) .OR. %LOC(IO$M_TIMED) .OR.
  115.      $               %LOC(IO$M_NOECHO)
  116.          INIT = .TRUE.
  117.       ENDIF
  118. C
  119. C INITIATE A SINGLE CHARACTER READ
  120. C
  121.       ISTAT = SYS$QIOW (%VAL(KEYBOARD_EF), %VAL(TERM_CHAN),
  122.      $                  %VAL(READ_FUNC), IOSB,,, CHAR, %VAL(1),
  123.      $                  %VAL(NO_TIME), NO_TERMINATORS,,)
  124. C
  125. C IGNORE ANY ERRORS
  126. C
  127.       IF (IOSB(STATUS) .NE. %LOC(SS$_NORMAL) .OR.
  128.      $    IOSB(BYTECNT) .NE. 1) CHAR = 0
  129.       RETURN
  130.       END
  131. C
  132. C---END KEYHIT
  133. C
  134.